home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / intrfc55.arc / NAMELIST.PAS < prev    next >
Pascal/Delphi Source File  |  1990-02-25  |  17KB  |  621 lines
  1. unit namelist;
  2. { These are the routines that print the name definitions }
  3.  
  4. interface
  5.  
  6. uses
  7.   dump,util,globals,loader,head,nametype;
  8.  
  9. var
  10.   last_kind : byte;
  11.   in_function : boolean;
  12.  
  13. procedure print_name_list(obj_list:list_ptr);
  14. procedure print_obj(obj:obj_ptr);
  15. procedure write_type_def(def:type_def_ptr);
  16. procedure write_type_info(var name:string; obj:obj_ptr; info:type_info_ptr);
  17. function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
  18. procedure write_var_type(type_unit,type_def_ofs:word);
  19. procedure write_var_info(var name:string; info:var_info_ptr);
  20. procedure write_args(arg:arg_ptr; num_args:word);
  21. procedure write_proc_type(var name:string; flags:code_flags; info:func_type_ptr);
  22. procedure write_proc_info(var name:string; info:func_info_ptr);
  23. procedure write_const_info(var name:string; info:const_info_ptr);
  24. procedure write_general(kind:byte; title,name,suffix:string);
  25. function find_name(unit_rec:unit_list_ptr;info_ofs:word):string;
  26. {  Unreliable way to get a name from a pointer to its info }
  27.  
  28. implementation
  29.  
  30. uses
  31.   blocks;
  32.  
  33. const
  34.   semicrlf = ';'+^M+^J;
  35.  
  36. function obj_ofs(obj:pointer):word;
  37. begin
  38.   obj_ofs := ptr_diff(obj,buffer);
  39. end;
  40.  
  41. procedure write_type_def(def:type_def_ptr);
  42. var
  43.   i : integer;
  44.   l : longint;
  45.   save_kind : byte;
  46.   field_list : list_ptr;
  47.   current : list_ptr;
  48.   obj : obj_ptr;
  49.   no_name : string;
  50.   save_in_array : boolean;
  51. begin
  52.   with def^ do
  53.     case type_type of
  54.       0 : write('untyped');
  55.       1 : begin                  {Array}
  56.             write('array[');
  57.             write_var_type(index_unit,index_ofs);
  58.             write('] of ');
  59.             write_var_type(element_unit,element_ofs);
  60.           end;
  61.       2 : begin                  {Record}
  62.             save_kind := last_kind;
  63.             last_kind := record_id;
  64.             writeln ('Record ');
  65.  
  66.             build_list(field_list,buffer,add_offset(buffer,hash_ofs));
  67.  
  68.             current := field_list;
  69.             inc(indentation,2);
  70.             while current^.offset < $ffff do
  71.             begin
  72.               obj := add_offset(buffer,current^.offset);
  73.               print_obj(obj);
  74.               current := current^.next;
  75.             end;
  76.             dec(indentation);
  77.             indent;
  78.             dec(indentation);
  79.             write('end');
  80.             last_kind := save_kind;
  81.           end;
  82.  
  83.       3 : begin                  {Object}
  84.             save_kind := last_kind;
  85.             last_kind := object_id;
  86.             write ('Object');
  87.             if parent_unit <> 0 then
  88.             begin
  89.               write('(');
  90.               write_var_type(parent_unit,parent_ofs);
  91.               write(')');
  92.             end;
  93.             writeln(tab,'{ vmt block ',hexword(handle),'}');
  94.  
  95.             build_list(field_list,buffer,add_offset(buffer,hash_ofs));
  96.  
  97.             inc(indentation,2);
  98.             current := field_list;
  99.             while current^.offset < $ffff do
  100.             begin
  101.               obj := add_offset(buffer,current^.offset);
  102.               print_obj(obj);
  103.               current := current^.next;
  104.             end;
  105.             dec(indentation);
  106.             indent;
  107.             write('end');
  108.             dec(indentation);
  109.             last_kind := save_kind;
  110.           end;
  111.  
  112.       4 : begin                  {File}
  113.             write('file');
  114.             if base_unit <> 0 then
  115.             begin
  116.               write(' of ');
  117.               write_var_type(base_unit,base_ofs);
  118.             end;
  119.           end;
  120.       5 : write('built-in text type');
  121.       6 : begin                  {function/procedure}
  122.             no_name := '';
  123.             write_proc_type(no_name,[],func_type_ptr(addr(return_ofs)));
  124.             writeln;
  125.           end;
  126.       7 : begin                  {Set}
  127.             write('set of ');
  128.             write_var_type(base_unit,base_ofs);
  129.           end;
  130.       8 : begin                  {Pointer}
  131.             write('^');
  132.             write_var_type(target_unit,target_ofs);
  133.           end;
  134.  
  135.       9 : begin                  {String}
  136.             write('string[',size-1,']');
  137.             {N.B. actually record is like array of char, but "string" with
  138.                   no length is different.}
  139.           end;
  140.      10 : write('built-in ',size,' byte 8087 type');    {8087}
  141.      11 : write('built-in 6-byte real');
  142.      12 : begin                  {Range}
  143.             write(lower,'..',upper);
  144.           end;
  145.      13 : write('built-in boolean');
  146.      14 : write('built-in char type');
  147.      15 : begin                  {Enumeration or subrange}
  148.             if (type_unit = unit_list[1]^.own_record)
  149.                and (type_ofs = obj_ofs(def)) then
  150.             begin
  151.               { Must be first definition }
  152.               write('(');
  153.               {  Assume following records are constant declarations  }
  154.               obj := add_offset(def,24);
  155.               for l:=lower to upper-1 do
  156.               begin
  157.                 write(obj^.name,',');
  158.                 obj:=add_offset(obj,12+length(obj^.name));
  159.               end;
  160.               write(obj^.name,')');
  161.             end
  162.             else
  163.             begin
  164.               { Must be subrange }
  165.               obj := add_offset(get_unit(type_unit)^.buffer,type_ofs);
  166.               obj := add_offset(obj,24);
  167.               i := 0;
  168.               while i < def^.lower do
  169.               begin
  170.                 obj:=add_offset(obj,12+length(obj^.name));
  171.                 inc(i);
  172.               end;
  173.               write(obj^.name);
  174.               while i < def^.upper do
  175.               begin
  176.                 obj:=add_offset(obj,12+length(obj^.name));
  177.                 inc(i);
  178.               end;
  179.               write('..',obj^.name);
  180.             end;
  181.           end;
  182.      else
  183.           begin
  184.             writeln('Type definition of type ',type_type, 'otherbyte=',
  185.                     other_byte,'size=',size);
  186.             indent;
  187.             write(' junk=');
  188.             for i:=3 to 8 do
  189.               write(who_knows[i]:6);
  190.             writeln;
  191.           end;
  192.     end;
  193. end;
  194.  
  195. procedure write_type_info(var name:string; obj:obj_ptr; info:type_info_ptr);
  196. var
  197.   def_obj : obj_ptr;
  198. begin
  199.   indent;
  200.   if (last_kind <> record_id) and (last_kind <> type_id) then
  201.   begin
  202.     writeln('type');
  203.     indent;
  204.     last_kind := type_id;
  205.   end;
  206.   write(oneindent,name,'=',oneindent);
  207.   with info^ do
  208.     if obj = find_type(get_unit(type_unit),type_def_ofs) then
  209.       write_type_def(add_offset(buffer,type_def_ofs))
  210.     else
  211.       write_var_type(type_unit,type_def_ofs);
  212.   writeln(';');
  213. end;
  214.  
  215. function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
  216. var
  217.   current:list_ptr;
  218.   obj : obj_ptr;
  219.   obj_info : type_info_ptr;
  220. begin
  221.   with unit_rec^ do
  222.   begin
  223.     if obj_list = nil then
  224.       build_list(obj_list,buffer,add_offset(buffer,header_ptr(buffer)^.ofs_hashtable));
  225.     current := obj_list;
  226.     while current^.offset < $ffff do
  227.     begin
  228.       obj := add_offset(buffer,current^.offset);
  229.       obj_info := add_offset(obj,4+length(obj^.name));
  230.       if     (obj^.obj_type = type_id)
  231.          and (obj_info^.type_def_ofs = def_ofs)
  232.          and (obj_info^.type_unit = own_record) then
  233.       begin
  234.         find_type := obj;
  235.         exit;
  236.       end;
  237.       current := current^.next;
  238.     end;
  239.     find_type := nil;
  240.   end;
  241. end;
  242.  
  243. function find_name(unit_rec:unit_list_ptr;info_ofs:word):string;
  244. {  Unreliable way to get a name from a pointer to its info }
  245. var
  246.   i:word;
  247.   name:string;
  248. begin
  249.   with unit_rec^ do
  250.   begin
  251.     if buffer <> nil then
  252.       for i:=info_ofs-2 downto 0 do
  253.         if i+buffer^[i]+1 = info_ofs then
  254.         begin
  255.           move(buffer^[i],name[0],buffer^[i]+1);
  256.           find_name := name;
  257.           exit;
  258.         end;
  259.   end;
  260.   find_name := '';
  261. end;
  262.  
  263. procedure write_var_type(type_unit,type_def_ofs:word);
  264. var
  265.   type_obj : obj_ptr;
  266.   unit_ptr : unit_list_ptr;
  267. begin
  268.   if type_unit > 0 then
  269.   begin
  270.     unit_ptr := get_unit(type_unit);
  271.     with unit_ptr^ do
  272.     begin
  273.       if buffer <> nil then
  274.       begin
  275.         type_obj := find_type(unit_ptr,type_def_ofs);
  276.         if type_obj <> nil then
  277.           write(type_obj^.name)
  278.         else
  279.           write_type_def(add_offset(buffer,type_def_ofs));
  280.       end
  281.       else
  282.         write(name,'.ofs',type_def_ofs);
  283.     end;
  284.   end
  285.   else
  286.     write('type_unit not found');
  287. end;
  288.  
  289. procedure write_var_info(var name:string; info:var_info_ptr);
  290. var
  291.   orig_unit:unit_list_ptr;
  292. begin
  293.   indent;
  294.   with info^ do
  295.   begin
  296.     if not (last_kind in [object_id,record_id]) then
  297.       case c_or_v and $FFE7 of
  298.         0 : write_general(var_id,'var',name,':'+oneindent);
  299.         1 : write_general(const_id,'const',name,':'+oneindent);
  300.         2 : write_general(local_id,'local var',name,':'+oneindent);
  301.         6 : write_general(referenced_id,'referenced var',name,':'+oneindent);
  302.         else write('C_or_V=',c_or_v,tab,name,':'+oneindent);
  303.       end
  304.     else
  305.       write(name,':',oneindent);
  306.  
  307.     write_var_type(type_unit,type_def_ofs);
  308.  
  309.     if (c_or_v and $10) <> 0 then
  310.     begin
  311.       write(' absolute ');
  312.       orig_unit := get_unit(in_unit);
  313.       if orig_unit <> nil then
  314.       begin
  315.         if orig_unit <> unit_list[1] then
  316.           write(orig_unit^.name,'.');
  317.         writeln(find_name(orig_unit,offset),';');
  318.       end
  319.       else
  320.         writeln('?????;');
  321.     end
  322.     else
  323.     begin
  324.       if c_or_v = 1 then
  325.         write('=',oneindent,'?');
  326.       if in_function then
  327.         write(';',tab,'{BP ofs ',integer(offset))
  328.       else
  329.       begin
  330.         write(';',tab,'{ofs ',hexword2(offset));
  331.         if not (last_kind in [record_id,object_id]) then
  332.           write(' in block ',hexword2(in_unit));
  333.       end;
  334.       writeln('}');
  335.     end;
  336.   end;
  337. end;
  338.  
  339. procedure write_args(arg:arg_ptr;num_args:word);
  340. var
  341.   i:word;
  342. begin
  343.   writeln('(');
  344.   inc(indentation);
  345.   for i:=1 to num_args do
  346.   begin
  347.     with arg^ do
  348.     begin
  349.       indent;
  350.       case var_or_val of
  351.       2 : write('    ');
  352.       6 : write('var ');
  353.       else
  354.         writeln('var_or_val=',var_or_val,', not 2 or 6!');
  355.         indent;
  356.       end;
  357.       write('arg',i,':',oneindent);
  358.       write_var_type(type_unit,type_def_ofs);
  359.       writeln(';');
  360.     end;
  361.     arg := add_offset(arg,sizeof(arg_rec));
  362.   end;
  363.   indent;
  364.   write(')');
  365.   dec(indentation);
  366. end;
  367.  
  368. procedure write_locals(var name:string; info:func_info_ptr);
  369. var
  370.   obj_list : list_ptr;
  371.   save_in_function : boolean;
  372. begin
  373.   if info^.local_hash = 0 then
  374.     exit;
  375.   save_in_function := in_function;
  376.   in_function := true;
  377.   build_list(obj_list,buffer,add_offset(buffer,info^.local_hash));
  378.   inc(indentation);
  379.   indent; writeln('{ ',name,' locals begin...}');
  380.   print_name_list(obj_list);
  381.   indent; writeln('{ ...',name,' locals end.}');
  382.   writeln;
  383.   dec(indentation);
  384.   in_function := save_in_function;
  385. end;
  386.  
  387.  
  388. procedure write_proc_type(var name:string; flags:code_flags; info:func_type_ptr);
  389. var
  390.   proc : boolean;
  391. begin
  392.   with info^ do
  393.   begin
  394.     if (type_def_ofs = 0) and (type_unit = 0) then
  395.       proc := true
  396.     else
  397.       proc := false;
  398.     if construct in flags then
  399.       write('constructor',oneindent,name)
  400.     else if destruct in flags then
  401.       write('destructor',oneindent,name)
  402.     else
  403.       if proc then
  404.         write('procedure',oneindent,name)
  405.       else
  406.         write('function',oneindent,name);
  407.     if info^.num_args > 0 then
  408.       write_args(arg_ptr(add_offset(info,sizeof(func_type_rec))),
  409.                  info^.num_args);
  410.     if not proc then
  411.     begin
  412.       write(':',oneindent);
  413.       write_var_type(type_unit,type_def_ofs);
  414.     end;
  415.   end;
  416.   write(';');
  417. end;
  418.  
  419. procedure write_proc_info(var name:string; info:func_info_ptr);
  420. var
  421.   entry_pt : entry_pt_ptr;
  422.   code : ^word;
  423.   i : word;
  424. begin
  425.   indent;
  426.   with info^ do
  427.   begin
  428.     write_proc_type(name,code_type,func_type_ptr(addr(func_type)));
  429.     if vmt_entry > 0 then
  430.       write(' virtual;');
  431.     if external_code in code_type then
  432.       write(oneindent,'external;');
  433.     if not (inline_code in code_type) then
  434.     begin
  435.       entry_pt := add_offset(buffer,header^.ofs_entry_pts+entry_ofs);
  436.       writeln(tab,'{ Proc ',hexword2(entry_ofs),
  437.                   ' Entry ',hexword2(entry_pt^.code_block),':',
  438.                             hexword(entry_pt^.offset),'}');
  439.     end;
  440.     if inline_code in code_type then
  441.     begin
  442.       writeln;
  443.       indent;
  444.       write(' Inline(');
  445.       code := add_offset(info,sizeof(func_info_rec)
  446.                              +func_type.num_args*sizeof(arg_rec));
  447.       for i:=1 to entry_ofs div 2 - 1 do
  448.       begin
  449.         write('$',hexbyte(hi(code^)):2,'/');
  450.         if lo(code^) <> 0 then
  451.           writeln('Low byte not zero!');
  452.         code := add_offset(code,sizeof(word));
  453.       end;
  454.       writeln('$',hexbyte(hi(code^)):2,');');
  455.       if lo(code^) <> 0 then
  456.         writeln('Low byte not zero!');
  457.     end;
  458.     if f4 in code_type then
  459.       writeln('Unknown flag f4 in code_type');
  460.     if f128 in code_type then
  461.       writeln('Unknown flag f128 in code_type');
  462.     if do_locals in active_options then
  463.       write_locals(name,info);
  464.   end;
  465. end;
  466.  
  467. procedure write_const_info(var name:string; info:const_info_ptr);
  468. var
  469.   type_obj : obj_ptr;
  470. begin
  471.   indent;
  472.   if (last_kind <> record_id) and (last_kind <> const_id) then
  473.   begin
  474.     writeln('Const');
  475.     indent;
  476.     last_kind := const_id;
  477.   end;
  478.   write(oneindent,name,'=',oneindent);
  479.   with info^,get_unit(type_unit)^ do
  480.   begin
  481.     if name = 'SYSTEM' then
  482.     case type_def_ofs of
  483.                 { Risky to fix these, but can't see any
  484.                                   other way to type constants }
  485.         $86:   write('''',stringval,'''');
  486.         $9E:   write(extendval);
  487.         $E6:   write(intval);
  488.         $FE:   write(boolval);
  489.  
  490.         else
  491.           write('?');
  492.     end
  493.     else
  494.       write('?');
  495.   end;
  496.   writeln(';');
  497. end;
  498.  
  499. procedure write_unit_info(var name:string; info:unit_ptr; self:boolean);
  500. begin
  501.   indent;
  502.   if self then
  503.   begin
  504.     write('Unit',oneindent,name,';');
  505.     last_kind := init_id;
  506.   end
  507.   else
  508.   begin
  509.     if last_kind = unit_id then
  510.       write(oneindent,',',name)
  511.     else
  512.     begin
  513.       write('Uses',oneindent,name);
  514.       last_kind := unit_id;
  515.     end;
  516.   end;
  517.   with info^ do
  518.   begin
  519.     writeln(tab,'{ checksum = ',hexword(checksum),'}');
  520.   end;
  521. end;
  522.  
  523. procedure write_general(kind:byte; title,name,suffix:string);
  524. begin
  525.   if last_kind <> kind then
  526.   begin
  527.     writeln(title);
  528.     last_kind := kind;
  529.     indent;
  530.   end;
  531.   write(oneindent,name,suffix);
  532. end;
  533.  
  534. procedure print_obj(obj:obj_ptr);
  535. var
  536.   j:word;
  537.   obj_info : ^byte_array;
  538.   new_entry : list_ptr;
  539.   info_len,info_ofs : word;
  540. const
  541.   known_types : set of byte = [var_id,unit_id,const_id,type_id,proc_id,
  542.                                sys_proc_id,sys_fn_id,sys_mem_id,sys_port_id,
  543.                                sys_new_id];
  544.   dump_types  : set of byte = [];
  545. begin
  546.   info_ofs := sizeof(obj_rec)-sizeof(string)+1+length(obj^.name);
  547.   obj_info := add_offset(obj,info_ofs);
  548.  
  549.   if obj^.obj_type in known_types then
  550.   begin
  551.     if obj^.obj_type = unit_id then
  552.     begin
  553.       add_unit(obj^.name);
  554.       if unit_ptr(obj_info)^.target = 0 then
  555.         unit_ptr(obj_info)^.target := get_unit_num(obj^.name);
  556.              {  Save our ID there, so references can find the information  }
  557.     end;
  558.  
  559.     case obj^.obj_type of
  560.        const_id : write_const_info(obj^.name,pointer(obj_info));
  561.        type_id : write_type_info(obj^.name,obj,pointer(obj_info));
  562.  
  563.        var_id  : write_var_info(obj^.name,pointer(obj_info));
  564.  
  565.        proc_id : begin
  566.                    write_proc_info(obj^.name,pointer(obj_info));
  567.                    last_kind := proc_id;
  568.                  end;
  569.  
  570.        sys_proc_id : write_general(sys_proc_id,'built-in procedure',obj^.name,semicrlf);
  571.  
  572.        sys_fn_id : write_general(sys_fn_id,'built-in function',obj^.name,semicrlf);
  573.  
  574.        sys_port_id : write_general(sys_port_id,'port array',obj^.name,semicrlf);
  575.  
  576.        sys_mem_id : write_general(sys_mem_id,'memory array',obj^.name,semicrlf);
  577.  
  578.        sys_new_id : write_general(sys_new_id,'system allocator',obj^.name,semicrlf);
  579.  
  580.        unit_id :   write_unit_info(obj^.name,pointer(obj_info),
  581.                      obj_ofs(obj) = header^.ofs_this_unit)
  582.  
  583.     end; {case}
  584.   end
  585.   else
  586.   begin
  587.     writeln('Unknown kind ',obj^.obj_type,oneindent,obj^.name,' with info at ',
  588.             hexword(obj_ofs(obj_info)));
  589.     last_kind := obj^.obj_type;
  590.   end;
  591.   if obj^.obj_type in dump_types then
  592.   begin
  593.     for j:=0 to 15 do
  594.       write(hexword(obj_ofs(obj_info)+j):5);
  595.     for j:=0 to 15 do
  596.       write(hexbyte(obj_info^[j]):5);
  597.     for j:=16 to 31 do
  598.       write(hexword(obj_ofs(obj_info)+j):5);
  599.     for j:=16 to 31 do
  600.       write(hexbyte(obj_info^[j]):5);
  601.   end;
  602. end;
  603.  
  604. procedure print_name_list(obj_list:list_ptr);
  605. var
  606.   obj : obj_ptr;
  607.   current : list_ptr;
  608.   bytes : ^byte_array;
  609.   j : integer;
  610. begin
  611.   last_kind := init_id;
  612.   current := obj_list;
  613.   while current^.offset < $ffff do
  614.   begin
  615.     obj := add_offset(buffer,current^.offset);
  616.     print_obj(obj);
  617.     current := current^.next;
  618.   end;
  619. end;
  620.  
  621. end.